home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Borland / Borland Pascal with Objects 7.0 / PXWIN.ZIP / PXDEMO.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-10-27  |  11.9 KB  |  410 lines
  1. {************************************************}
  2. {                                                }
  3. {   Paradox Engine demo program                  }
  4. {   Copyright (c) 1992 by Borland International  }
  5. {                                                }
  6. {************************************************}
  7.  
  8. { Note: This demo requires version 3.0 of the Paradox Engine. }
  9.  
  10. program PXDemo;
  11.  
  12. {$R PXDEMO.RES}
  13. {$N+}
  14.  
  15. uses WinTypes, WinProcs, Strings, Objects, OWindows, OStdDlgs, 
  16.   PXEngWin, PXMsg, PXAccess;
  17.  
  18. const
  19.   BKColor   = $00FFFF00;
  20.   ForeColor = $00000000;
  21.  
  22. const
  23.   cm_FileClose = 100;
  24.  
  25. const
  26.   MenuID      = 100;
  27.   IconID      = 100;
  28.  
  29. type
  30.   TParadoxDemo = object(TApplication)
  31.     destructor Done; virtual;
  32.     procedure InitMainWindow; virtual;
  33.     procedure Error(errorCode: Integer); virtual;
  34.   end;
  35.  
  36.   PParadoxTableWindow = ^TParadoxTableWindow;
  37.   TParadoxTableWindow = object(TWindow)
  38.     CharWidth: Integer;
  39.     CharHeight: Integer;
  40.     TableWidth: Integer;
  41.     FixedFont: HFont;
  42.     Table: PPXTable;
  43.     FieldStarts: PWordArray;
  44.     TitleBar: HBitmap;
  45.     ColumnBar: HBitmap;
  46.     constructor Init(AParent: PWindowsObject; TableName: PChar);
  47.     destructor Done; virtual;
  48.     procedure CloseTable;
  49.     function GetClassName: PChar; virtual;
  50.     procedure GetFixedFont(DC: HDC);
  51.     procedure GetWindowClass(var WndClass: TWndClass); virtual;
  52.     procedure Paint(DC: HDC; var PS: TPaintStruct); virtual;
  53.     procedure SetupWindow; virtual;
  54.     procedure CMFileClose(var Message: TMessage);
  55.       virtual cm_First + cm_FileClose;
  56.     procedure CMFileOpen(var Message: TMessage);
  57.       virtual cm_First + cm_FileOpen;
  58.     procedure WMKeyDown(var Msg: TMessage);
  59.       virtual wm_First + wm_KeyDown;
  60.     procedure WMSize(var Msg: TMessage);
  61.       virtual wm_First + wm_Size;
  62.   end;
  63.  
  64. { TParadoxDemo }
  65.  
  66. destructor TParadoxDemo.Done;
  67. begin
  68.   TApplication.Done;
  69.   PXExit;
  70. end;
  71.  
  72. procedure TParadoxDemo.InitMainWindow;
  73. begin
  74.   Status := PXWinInit('PXDemo', PXExclusive);
  75.   if Status = PXSuccess then
  76.     MainWindow := New(PParadoxTableWindow, Init(nil, 'Paradox Table Viewer'))
  77.   else MessageBox(0, PXErrMsg(Status), 'PXDemo', mb_OK)
  78. end;
  79.  
  80. procedure TParadoxDemo.Error(ErrorCode: Integer);
  81. begin
  82.   if Status < 0 then TApplication.Error(ErrorCode)
  83.   else MessageBox(GetFocus, PXErrMsg(Status), 'WinTable', MB_OK);
  84. end;
  85.  
  86. { TParadoxTableWindow }
  87.  
  88. constructor TParadoxTableWindow.Init(AParent: PWindowsObject;
  89.   TableName: PChar);
  90. begin
  91.   TWindow.Init(AParent, TableName);
  92.   with Attr do
  93.   begin
  94.     Menu := LoadMenu(HInstance, MakeIntResource(MenuID));
  95.     Style := Style or ws_VScroll or ws_HScroll;
  96.     X := 25;
  97.     Y := 40;
  98.     W := 500;
  99.     H := 350;
  100.   end;
  101.   Scroller := New(PScroller, Init(@Self, 1, 1, 0, 0));
  102.   Scroller^.TrackMode := False;
  103.   Scroller^.AutoOrg := False;
  104.   Table := nil;
  105.   FieldStarts := nil;
  106.   TitleBar := 0;
  107.   ColumnBar := 0;
  108. end;
  109.  
  110. destructor TParadoxTableWindow.Done;
  111. begin
  112.   CloseTable;
  113.   TWindow.Done;
  114. end;
  115.  
  116. procedure TParadoxTableWindow.CloseTable;
  117. begin
  118.   if Table <> nil then
  119.   begin
  120.     FreeMem(FieldStarts, SizeOf(Word) * (Table^.NumFields + 2));
  121.     FieldStarts := nil;
  122.     Dispose(Table, Done);
  123.     Table := nil;
  124.     DeleteObject(TitleBar);
  125.     InvalidateRect(HWindow, nil, True);
  126.   end;
  127. end;
  128.  
  129. procedure TParadoxTableWindow.CMFileClose(var Message: TMessage);
  130. begin
  131.   CloseTable;
  132. end;
  133.  
  134. procedure TParadoxTableWindow.CMFileOpen(var Message: TMessage);
  135. var
  136.   Filename: array[0..128] of Char;
  137.   I: Integer;
  138.   DC, MemDC: HDC;
  139.   OldBrush: HBrush;
  140.   OldPen: HPen;
  141.   R: TRect;
  142.   SepX, SepY, TitleWidth: Integer;
  143.   FieldStart, FieldEnd: Integer;
  144.  
  145. function Min(X,Y: Integer): Integer;
  146. begin
  147.   if X < Y then Min := X else Min := Y;
  148. end;
  149.  
  150. begin
  151.   if Application^.ExecDialog(New(PFileDialog, Init(@Self, PChar(sd_FileOpen),
  152.     StrCopy(FileName, '*.db')))) = idOK then
  153.   begin
  154.     CloseTable;
  155.     Table := New(PPXTable, Init(FileName));
  156.     if Table^.Status <> 0 then
  157.     begin
  158.       Dispose(Table, Done);
  159.       Table := nil;
  160.     end
  161.     else
  162.     begin
  163.       { Record Field starts }
  164.       GetMem(FieldStarts, SizeOf(Word) * (Table^.NumFields + 2));
  165.       FieldStarts^[1] := 0;
  166.       for I := 2 to Table^.NumFields + 1 do
  167.         FieldStarts^[I] := Table^.FieldWidth(I - 1) + FieldStarts^[I - 1] + 1;
  168.       TableWidth := FieldStarts^[I];
  169.       GetClientRect(HWindow, R);
  170.       Scroller^.SetRange(TableWidth - R.right div CharWidth,
  171.         Table^.NumRecords - R.bottom div CharHeight);
  172.  
  173.       { Create the title bar bitmap }
  174.       DC := GetDC(HWindow);
  175.       MemDC := CreateCompatibleDC(DC);
  176.       ReleaseDC(HWindow, DC);
  177.       TitleWidth := TableWidth * CharWidth;
  178.       TitleBar := CreateCompatibleBitmap(DC, TitleWidth, CharHeight);
  179.       SelectObject(MemDC, TitleBar);
  180.       SelectObject(MemDC, FixedFont);
  181.       SetTextColor(MemDC, ForeColor);
  182.       SetBkColor(MemDC, BKColor);
  183.       OldBrush := SelectObject(MemDC, CreateSolidBrush(BKColor));
  184.       PatBlt(MemDC, 0, 0, TitleWidth, CharHeight, PatCopy);
  185.       DeleteObject(SelectObject(MemDC, OldBrush));
  186.  
  187.       { Draw double lines }
  188.       OldPen := SelectObject(MemDC, CreatePen(ps_Solid, 2, ForeColor));
  189.       SepX := CharWidth div 3;
  190.       SepY := CharHeight div 3;
  191.       {   Top line }
  192.       MoveTo(MemDC, SepX, SepY);
  193.       LineTo(MemDC, TitleWidth - SepX, SepY);
  194.       LineTo(MemDC, TitleWidth - SepX, CharHeight + 1);
  195.       {   Bottom lines and titles}
  196.       Inc(SepY, SepY);
  197.       for I := 1 to  Table^.NumFields do
  198.       begin
  199.         FieldStart := FieldStarts^[I] * CharWidth;
  200.         FieldEnd := FieldStart + Table^.FieldWidth(I) * CharWidth;
  201.         MoveTo(MemDC, FieldStart - SepX, CharHeight);
  202.         LineTo(MemDC, FieldStart - SepX, SepY);
  203.         LineTo(MemDC, FieldEnd + SepX, SepY);
  204.         LineTo(MemDC, FieldEnd + SepX, CharHeight + 1);
  205.         TextOut(MemDC, FieldStart, 0, Table^.FieldName(I),
  206.           Min(StrLen(Table^.FieldName(I)), Table^.FieldWidth(I)));
  207.       end;
  208.       DeleteObject(SelectObject(MemDC, OldPen));
  209.       DeleteDC(MemDC);
  210.       InvalidateRect(HWindow, nil, True);
  211.     end;
  212.   end;
  213. end;
  214.  
  215. function TParadoxTableWindow.GetClassName: PChar;
  216. begin
  217.   GetClassName := 'TurboTableView';
  218. end;
  219.  
  220. function EnumerateFont(LogFont: PLogFont; TextMetric: PTextMetric;
  221.   FontType: Integer; Data: Pointer): Bool; export;
  222. begin
  223.   PLogFont(Data)^ := LogFont^;
  224.   EnumerateFont := (TextMetric^.tmPitchAndFamily and 1) = 1;
  225. end;
  226.  
  227. procedure TParadoxTableWindow.GetFixedFont(DC: HDC);
  228. var
  229.   LogFont: TLogFont;
  230.   FontFunc: TFarProc;
  231. begin
  232.   FontFunc := MakeProcInstance(@EnumerateFont, HInstance);
  233.   EnumFonts(DC, 'SYSTEM', FontFunc, @LogFont);
  234.   FixedFont := CreateFontIndirect(LogFont);
  235.   FreeProcInstance(FontFunc);
  236. end;
  237.  
  238. procedure TParadoxTableWindow.GetWindowClass(var WndClass: TWndClass);
  239. var
  240.   LogBrush: TLogBrush;
  241. begin
  242.   TWindow.GetWindowClass(WndClass);
  243.   LogBrush.lbStyle := bs_Solid;
  244.   LogBrush.lbColor := BKColor;
  245.   WndClass.hbrBackground := CreateBrushIndirect(LogBrush);
  246.   WndClass.hIcon := LoadIcon(HInstance, MakeIntResource(IconID));
  247. end;
  248.  
  249. procedure TParadoxTableWindow.Paint(DC: HDC; var PS: TPaintStruct);
  250. var
  251.   OldFont: HFont;
  252.   OldCursor: HCursor;
  253.   HRgn1, HRgn2: HRgn;
  254.   MemDC: HDC;
  255.   StartX, StopX: Integer;
  256.   FirstField, LastField, FirstRec, LastRec: Integer;
  257.   I, J: Integer;
  258.   R: TRect;
  259.  
  260. procedure DrawField(X, Y, Width: Integer; FieldText: PChar);
  261. var
  262.   Temp: array[0..255] of Char;
  263.   XPos, YPos, Len: Integer;
  264.   R: TRect;
  265. begin
  266.   XPos := (X - Scroller^.XPos) * CharWidth;
  267.   YPos := (Y - Scroller^.YPos) * CharHeight;
  268.   Len := StrLen(FieldText);
  269.   TextOut(DC, XPos, YPos, FieldText, Len);
  270.   if Width > Len then
  271.   begin
  272.     FillChar(Temp, SizeOf(Temp), ' ');
  273.     TextOut(DC, XPos + Len * CharWidth, YPos, Temp, Width - Len);
  274.   end;
  275. end;
  276.  
  277. begin
  278.   if Table <> nil then
  279.   begin
  280.     SetTextColor(DC, ForeColor);
  281.     SetBkColor(DC, BKColor);
  282.     OldFont := SelectObject(DC, FixedFont);
  283.     StartX := (PS.rcPaint.left div CharWidth) + Scroller^.XPos;
  284.     StopX := (PS.rcPaint.right div CharWidth + 1) + Scroller^.XPos;
  285.     FirstField := 1;
  286.     while FieldStarts^[FirstField+1] <= StartX do Inc(FirstField);
  287.     LastField := Table^.NumFields;
  288.     while FieldStarts^[LastField] >= StopX do Dec(LastField);
  289.     FirstRec := (PS.rcPaint.top div CharHeight) + Scroller^.YPos;
  290.     LastRec := (PS.rcPaint.bottom div CharHeight + 1) + Scroller^.YPos + 1;
  291.     MemDC := CreateCompatibleDC(DC);
  292.     SelectObject(MemDC, ColumnBar);
  293.     for I := FirstField to LastField do
  294.     begin
  295.       J := (FieldStarts^[I + 1] - Scroller^.XPos - 1) * CharWidth;
  296.       BitBlt(DC, J, PS.rcPaint.top, J + CharWidth, PS.rcPaint.bottom,
  297.         MemDC, 0, 0, SrcCopy);
  298.     end;
  299.     DeleteDC(MemDC);
  300.     OldCursor := SetCursor(LoadCursor(0, idc_Wait));
  301.  
  302.     for I := FirstRec to LastRec do
  303.       if I = 0 then
  304.       begin
  305.         MemDC := CreateCompatibleDC(DC);
  306.         SelectObject(MemDC, TitleBar);
  307.         BitBlt(DC, 0, 0, (TableWidth - Scroller^.XPos) * CharWidth,
  308.           CharHeight, MemDC, Scroller^.XPos * CharWidth, 0, SrcCopy);
  309.         DeleteDC(MemDC);
  310.       end
  311.       else
  312.         for J := FirstField to LastField do
  313.           DrawField(FieldStarts^[J], I, Table^.FieldWidth(J),
  314.             Table^.GetField(I, J));
  315.     SetCursor(OldCursor);
  316.     SelectObject(DC, OldFont);
  317.     if Table^.Status <> 0 then CloseTable;
  318.   end;
  319. end;
  320.  
  321. procedure TParadoxTableWindow.SetupWindow;
  322. var
  323.   TextMetric: TTextMetric;
  324.   DC: HDC;
  325.   OldFont: THandle;
  326. begin
  327.   TWindow.SetupWindow;
  328.   DC := GetDC(HWindow);
  329.   GetFixedFont(DC);
  330.   OldFont := SelectObject(DC, FixedFont);
  331.   GetTextMetrics(DC, TextMetric);
  332.   CharWidth := TextMetric.tmAveCharWidth;
  333.   CharHeight := TextMetric.tmHeight;
  334.   Scroller^.SetUnits(CharWidth, CharHeight);
  335.   SelectObject(DC, OldFont);
  336.   ReleaseDC(HWindow, DC);
  337.   Scroller^.SetSBarRange;
  338. end;
  339.  
  340. procedure TParadoxTableWindow.WMKeyDown(var Msg: TMessage);
  341. begin
  342.   with Scroller^ do
  343.     case Msg.wParam of
  344.       vk_Left:
  345.         if GetKeyState(vk_Control) and $8000 <> 0 then
  346.           HScroll(sb_PageUp, 0)
  347.         else
  348.           HScroll(sb_LineUp, 0);
  349.       vk_Right:
  350.         if GetKeyState(vk_Control) and $8000 <> 0 then
  351.           HScroll(sb_PageDown, 0)
  352.         else
  353.           HScroll(sb_LineDown, 0);
  354.       vk_Up: VScroll(sb_LineUp, 0);
  355.       vk_Down: VScroll(sb_LineDown, 0);
  356.       vk_Next: VScroll(sb_PageDown, 0);
  357.       vk_Prior: VScroll(sb_PageUp, 0);
  358.       vk_Home: ScrollTo(XPos, 0);
  359.       vk_End: ScrollTo(XPos, Table^.NumRecords);
  360.     end;
  361. end;
  362.  
  363. procedure TParadoxTableWindow.WMSize(var Msg: TMessage);
  364. var
  365.   R: TRect;
  366.   DC, MemDC: HDC;
  367.   OldBrush: HBrush;
  368.   OldPen: HPen;
  369.   SepX: Integer;
  370. begin
  371.   TWindow.WMSize(Msg);
  372.   if Table <> nil then
  373.   begin
  374.     GetClientRect(HWindow, R);
  375.     Scroller^.SetRange(TableWidth - R.right div CharWidth,
  376.       Table^.NumRecords - R.bottom div CharHeight + 1);
  377.     { Call GetClientRect again because SetRange can change the size of
  378.       the client area if a scrollbar disappears }
  379.     GetClientRect(HWindow, R);
  380.     if ColumnBar <> 0 then DeleteObject(ColumnBar);
  381.     DC := GetDC(HWindow);
  382.     MemDC := CreateCompatibleDC(DC);
  383.     ReleaseDC(HWindow, DC);
  384.     ColumnBar := CreateCompatibleBitmap(DC, CharWidth,
  385.       R.bottom * CharHeight);
  386.     SelectObject(MemDC, ColumnBar);
  387.     SetTextColor(MemDC, ForeColor);
  388.     SetBKColor(MemDC, BKColor);
  389.     OldBrush := SelectObject(MemDC, CreateSolidBrush(BKColor));
  390.     PatBlt(MemDC, 0, 0, CharWidth, R.bottom * CharHeight, PatCopy);
  391.     DeleteObject(SelectObject(MemDC, OldBrush));
  392.     OldPen := SelectObject(MemDC, CreatePen(ps_Solid, 2, ForeColor));
  393.     SepX := CharWidth div 3;
  394.     MoveTo(MemDC, SepX, 0);
  395.     LineTo(MemDC, SepX, R.bottom);
  396.     MoveTo(MemDC, CharWidth - SepX, 0);
  397.     LineTo(MemDC, CharWidth - SepX, R.bottom);
  398.     DeleteObject(SelectObject(MemDC, OldPen));
  399.     DeleteDC(MemDC);
  400.   end;
  401. end;
  402.  
  403. var
  404.   ParadoxDemo: TParadoxDemo;
  405. begin
  406.   ParadoxDemo.Init('ParadoxDemo');
  407.   ParadoxDemo.Run;
  408.   ParadoxDemo.Done;
  409. end.
  410.